Option Explicit
Sub カッコ置換()
Dim myStr As String
Dim a As Variant '固定処理の為の置換用関数
Dim b As Variant '固定処理の為の置換用関数
Dim i As Integer '固定処理の為の置換用関数
Dim rc As Integer 'メッセージボックスのYesNoの為の関数
Dim rng As Range
'検索文字列------------------------------------------------------------------------------------------
a = Array("(", ")", "%", "[", "]", "｢", "｣")

'置換文字列-----------------------------------------------------------------------------------------
b = Array("（", "）", "％", "［", "］", "「", "」")
'----------------------------------------------------------------------------------------------------
For i = LBound(a) To UBound(a)

Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = a(i)
.Replacement.Text = b(i)
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
.MatchFuzzy = True
End With
Selection.Find.Execute Replace:=wdReplaceAll

Next

Application.ScreenUpdating = True '描画開始

End Sub
Sub 算用to漢数字変換()
'------------------------------------------------------------------------
'○呼び出すサブルーチン：
'  �@conv2kan(skan, setketa)
'     ※setketa:1(KETAMOJI)で桁文字（十百千）使用、0(NOKETA)で桁文字不使用
'------------------------------------------------------------------------
'
    Dim rc As Integer
    rc = MsgBox("ルビ文字は文字飛びが出る場合があります。Alt+F9を押下し、検索でEQと入力し確認して下さい。確認後、Alt+F9を押下し非表示にしておいて下さい。確認済みの場合は【はい】をクリックして下さい。", vbYesNo + vbQuestion, "確認")
    If rc = vbYes Then
        MsgBox "処理を行います。"
    Else
        MsgBox "処理はキャンセルされました。"
        Exit Sub
    End If
ActiveDocument.TrackRevisions = True
Selection.WholeStory
  Const KETAMOJI = 0  ' 七千三十五
  Const NOKETA = 1    ' 七○三五
  Dim flgketa As Long
   ' flgketa設定：(漢数くん使用時は引数使用)
   ' 0(KETAMOJI)…千百十使う。／0(NOKETA)…千百十使わない
  Dim str As String
  Dim piriunit As String
  Dim strbuf As String, pstr As String
  Dim RE As Object, RE2 As Object, Matches As Object, Match As Object
  Dim myRange As Range
  Dim para As Paragraph
  Dim buf As String
  Set RE = CreateObject("VBScript.RegExp")
  Set RE2 = CreateObject("VBScript.RegExp")
  RE.Global = False   'True:全ての検索結果を処理、False:初出の結果のみ処理
  RE2.Global = False
   
    ' ピリオド単位
  piriunit = "(．|\.)"
  
    ' 変換範囲（段落：paragraph単位で変換）
  If Selection.Start = Selection.End Then
    Set myRange = ActiveDocument.Range   '範囲選択しなければ文書全体
  Else
    Set myRange = Selection.Range    '選択された範囲内の段落のみ
  End If
  
  For Each para In myRange.Paragraphs
      ' 途中でパラグラフを移動させないため、文字列bufにコピーして作業
    buf = para.Range.Text
    
    ' 先に小数点[．|.]以下を変換（「三○五四」のようにベタ変換）
    RE.Pattern = piriunit & "([0-9]+|[０１２３４５６７８９]+)"
    Do
      Set Matches = RE.Execute(buf)
      If Matches.Count > 0 Then
        str = conv2kan(Matches(0).SubMatches(1), NOKETA)
        str = "・" & str
        RE2.Pattern = Matches(0).Value
        buf = RE2.Replace(buf, str)
      End If
    Loop Until Matches.Count = 0
   
    '「NN,NNN,NNN,NNN ／　N,NNN億、N,NNN万」変換
    RE.Pattern = "([0-9,]+|[０１２３４５６７８９，]+)"
    Do
      Set Matches = RE.Execute(buf)
      If Matches.Count > 0 Then
        strbuf = Replace(Matches(0).SubMatches(0), ",", "") 'カンマ削除
        str = ""
        If Len(strbuf) > 16 Then
          pstr = Left(strbuf, Len(strbuf) - 16)
          str = conv2kan(pstr, flgketa) & "京"
          strbuf = Right(strbuf, 16)
        End If
        If Len(strbuf) > 12 Then
          pstr = Left(strbuf, Len(strbuf) - 12)
          str = conv2kan(pstr, flgketa) & "兆"
          strbuf = Right(strbuf, 12)
        End If
        If Len(strbuf) > 8 Then
          pstr = Left(strbuf, Len(strbuf) - 8)
          str = str & conv2kan(pstr, flgketa) & "億"
          strbuf = Right(strbuf, 8)
        End If
        If Len(strbuf) > 4 Then
          pstr = Left(strbuf, Len(strbuf) - 4)
          str = str & conv2kan(pstr, flgketa) & "万"
          strbuf = Right(strbuf, 4)
        End If
        If Len(strbuf) > 0 Then
          pstr = strbuf
          str = str & conv2kan(pstr, flgketa)
        End If
        RE2.Pattern = Matches(0).Value
        buf = RE2.Replace(buf, str)
      End If
    Loop Until Matches.Count = 0
      ' 作業bufが変更されていたら、paragraph置き換え
    If buf <> para.Range.Text Then
      para.Range.Text = buf
    End If
  Next
  Set RE = Nothing
  Set Matches = Nothing
  Set Match = Nothing
  Set myRange = Nothing
ActiveDocument.TrackRevisions = False
End Sub

Function conv2kan(ssan As String, Optional setketa As Long) As String
'
'---------------------------------------------------------------------
'     ssan  ：処理する英数字（「0-9」,「０-９」どちらも可）
'     setketa：1(KETAMOJI)で桁文字（十百千）使用、0(NOKETA)で桁文字不使用
' ○戻り値
'     変換結果の文字列
'---------------------------------------------------------------------
'
    Const KETAMOJI = 1
    Const NOKETA = 0
    Const ALwpNUM = "０１２３４５６７８９，．"
    Const ALpNUM = "0123456789,."
    Const KANKETA2 = "一十百千"     '桁漢字（一〜千)
    Const KANNUM = "一二三四五六七八九"  '桁漢字あり用
    Const KANopNUM = "〇一二三四五六七八九、・"  '桁漢字無(ピリオド付き）
    Dim sbuf As String, swork As String
    Dim ileng As Long
    Dim iketa As Long, pos As Long, i As Long, cnt As Long
    
    ileng = Len(ssan)
    pos = ileng      'pos:漢字文字列中の処理中文字ポインタ
    iketa = 1       '現在処理中の英数字の桁数
    '全部半角に変換
    swork = ""
    pos = 0
    For i = 1 To ileng
      pos = InStr(ALwpNUM, Mid(ssan, i, 1))
      If pos > 0 Then
        swork = swork & Mid(ALpNUM, pos, 1)
      Else
        swork = swork & Mid(ssan, i, 1)
      End If
    Next
    sbuf = ""
    If setketa = NOKETA Then
      '桁漢字を使わない表記の場合（例：一七〇五）
      For i = 1 To ileng
        cnt = InStr(ALpNUM, Mid(swork, i, 1))
        sbuf = sbuf & Mid(KANopNUM, cnt, 1)
      Next
      conv2kan = sbuf
      Exit Function
    Else
      '桁漢字を使った表記の場合 （例：千七百五）
      swork = Replace(swork, ",", "") 'カンマ削除
      iketa = 1           '現在処理中の英数字の桁数
      ileng = Len(swork)      '文字列長再取得
      For i = ileng To 1 Step -1
        cnt = Val(Mid(swork, i, 1))
        If cnt = 1 Then
          sbuf = Mid(KANKETA2, iketa, 1) & sbuf
        ElseIf cnt >= 2 And cnt <= 9 Then
          If iketa = 1 Then
            sbuf = Mid(KANNUM, cnt, 1) & sbuf
          Else
            sbuf = Mid(KANKETA2, iketa, 1) & sbuf
            sbuf = Mid(KANNUM, cnt, 1) & sbuf
          End If
        End If
        iketa = iketa + 1
      Next
    End If
    conv2kan = sbuf
    Exit Function
End Function

Sub AAA横書きAAA数字と簡易文字全角変換v151130()
'----------------------------------------------------------------------------------------------------
'関数セット
Dim myStr As String
Dim a As Variant '固定処理の為の置換用関数
Dim b As Variant '固定処理の為の置換用関数
Dim i As Integer '固定処理の為の置換用関数
Dim rc As Integer 'メッセージボックスのYesNoの為の関数
Dim rng As Range
'----------------------------------------------------------------------------------------------------
    MsgBox "(注)１【校閲タブ】→【変更履歴の記録】→【オプション】→【吹き" & vbCrLf & _
           " 　　　出しダイアログ】の設定を【常に使用する】にしてマクロを実" & vbCrLf & _
           " 　　　行して下さい。" & vbCrLf & _
           "(注)２【ルビ付きの数字】がある場合ルビを外して下さい。" & vbCrLf & _
           "　　　 ", vbQuestion, "確認項目1"
    rc = MsgBox("Ctrl+E,Ctrl+Lを押して不要スペースを削除しましたか？", vbYesNo + vbQuestion, "確認項目2")
    If rc = vbYes Then
    Else
        MsgBox "処理はキャンセルされました。"
        Exit Sub
    End If

'--------------------------
Dim c As String
rc = MsgBox("ドットやコロンを含んだ数字を全角にしますか？", vbYesNo + vbQuestion, "確認項目3")
    If rc = vbYes Then
        c = "[０-９,.]{2,}"
    Else
        c = "[０-９,.]"

    End If

'--------------------------
'----------------------------------------------------------------------------------------------------
'履歴を最少にするために回りくどい処理をして変更履歴の記録開始
Dim motorireki As String
motorireki = ActiveDocument.TrackRevisions
If motorireki = False Then
ActiveDocument.TrackRevisions = True
End If
'----------------------------------------------------------------------------------------------------

'全角数字等が続くものは半角にする（.,も含む場合は右記のVBAを三段下の.Textを置換）　.Text = "[０-９．，.,]{2,}
Selection.Find.ClearFormatting
With Selection.Find
.Text = c
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchFuzzy = False
.MatchWildcards = True
End With
Do While Selection.Find.Execute = True
Selection.Text = StrConv(Selection.Text, vbNarrow)
Selection.Collapse wdCollapseEnd
Loop

'４3のたぐいに対処
Selection.Find.ClearFormatting
With Selection.Find
.Text = "[０-９][0-9]"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchFuzzy = False
.MatchWildcards = True
End With
Do While Selection.Find.Execute = True
Selection.Text = StrConv(Selection.Text, vbNarrow)
Selection.Collapse wdCollapseEnd
Loop

'3４、のたぐいに対処
Selection.Find.ClearFormatting
With Selection.Find
.Text = "[0-9][０-９]"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchFuzzy = False
.MatchWildcards = True
End With
Do While Selection.Find.Execute = True
Selection.Text = StrConv(Selection.Text, vbNarrow)
Selection.Collapse wdCollapseEnd
Loop

'前後に半角数字等がつかない数字等を全角にする
Selection.Find.ClearFormatting
With Selection.Find
.Text = "[!0-9.,][0-9][!0-9.,]"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchFuzzy = False
.MatchWildcards = True
End With
Do While Selection.Find.Execute = True

'先頭の一文字を選択範囲から外す
Selection.MoveStart unit:=wdCharacter, Count:=1

'最後の一文字を選択範囲から外す
Selection.MoveEnd unit:=wdCharacter, Count:=-1

'全角に変換
Selection.Text = StrConv(Selection.Text, vbWide)
Selection.Collapse wdCollapseEnd
Loop

'変更履歴記録を終了
If motorireki = False Then
ActiveDocument.TrackRevisions = False
End If
rc = MsgBox("コロンは句読点にしますか？（半角コロンは句読点に変換しませんのでご注意を！）", vbYesNo + vbQuestion, "確認項目4")
    If rc = vbYes Then
        a = Array("，")
        b = Array("、")
    Else
        a = Array("、")
        b = Array("，")
    End If

For i = LBound(a) To UBound(a)

Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = a(i)
.Replacement.Text = b(i)
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = True
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
.MatchFuzzy = True
End With
Selection.Find.Execute Replace:=wdReplaceAll

Next
    
'----------------------------------------------------------------------------------------------------
    rc = MsgBox("半角カッコ,半角スペース,~,%,（代）,（株）,（有）,（１）〜（15）" & vbCrLf & "【・・・】を全角２バイト置換しますか？" & vbCrLf & _
    "この処理は機種依存文字へ置換処理をしますので記録はできません。", vbYesNo + vbQuestion, "これはしてもしなくても良いです")
    If rc = vbYes Then
    Else
        MsgBox "処理はキャンセルされました。"
        Exit Sub
    End If
    ActiveDocument.AcceptAllRevisions
'----------------------------------------------------------------------------------------------------
'空白全角変換(処理対象文書の先頭位置をrngに格納)

Application.ScreenUpdating = False '描画停止


Set rng = ActiveDocument.Range(0, 0)
With rng.Find

'検索条件として半角空白を指定
.Text = " "
.MatchWildcards = False
End With

With rng
'検索箇所が見つかる間は処理を繰り返す
Do While .Find.Execute = True

'半角空白が見つかった場合、全角空白に変換
.Text = "　"

'rngが示す範囲の先頭位置を現在の末尾に変更する(検索結果の末尾に変更)
.SetRange .End, .End
Loop
End With
'----------------------------------------------------------------------------------------------------
    Selection.WholeStory
    Selection.Find.ClearFormatting
    With Selection.Find
    
        .Text = "[a-zA-Z,.]　[,.a-zA-Z]"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchByte = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchFuzzy = False
        .MatchWildcards = True
    End With
Do While Selection.Find.Execute = True
Selection.Text = StrConv(Selection.Text, vbNarrow)
Selection.Collapse wdCollapseEnd
Loop
    Selection.HomeKey unit:=wdLine
'----------------------------------------------------------------------------------------------------



'検索文字列------------------------------------------------------------------------------------------
a = Array("(", ")", "%", "（代）", "（株）", "（有）", "（１）", "（２）", "（３）", "（４）", "（５）", "~", _
"（６）", "（７）", "（８）", "（９）", "（10）", "（11）", "（12）", "（13）", "（14）", "（15）", "・・・", "[", "]", "｢", "｣")

'置換文字列-----------------------------------------------------------------------------------------
b = Array("（", "）", "％", "��", "��", "��", ChrW(&H2474), ChrW(&H2475), ChrW(&H2476), ChrW(&H2477), ChrW(&H2478), "〜", _
ChrW(&H2479), ChrW(&H247A), ChrW(&H247B), ChrW(&H247C), ChrW(&H247D), ChrW(&H247E), ChrW(&H247F), ChrW(&H2480), ChrW(&H2481), ChrW(&H2482), "…", "［", "］", "「", "」")
'----------------------------------------------------------------------------------------------------
For i = LBound(a) To UBound(a)

Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = a(i)
.Replacement.Text = b(i)
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
.MatchFuzzy = True
End With
Selection.Find.Execute Replace:=wdReplaceAll

Next

Application.ScreenUpdating = True '描画開始

End Sub

Sub ルビ一括削除()
ActiveDocument.TrackRevisions = True
Selection.WholeStory
Dim F As Variant
With ActiveDocument
For Each F In .Fields
    If InStr(F.Code.FormattedText.Text, "\up") > 0 Then
    F.Select
    With Selection
      .Range.PhoneticGuide ""
    End With
    End If
Next
End With
ActiveDocument.TrackRevisions = False
End Sub

Sub 簡易文字全角()
Dim a As Variant '固定処理の為の置換用関数
Dim b As Variant '固定処理の為の置換用関数
Dim i As Integer '固定処理の為の置換用関数
Dim rc As Integer 'メッセージボックスのYesNoの為の関数
Dim rng As Range
Selection.WholeStory
'----------------------------------------------------------------------------------------------------
    rc = MsgBox("   半角カッコ,半角スペース,~,%,（代）,（株）,（有）,（１）〜（15）" & vbCrLf & "【・・・】を全角２バイト置換しますか？" & vbCrLf & _
    "この処理は機種依存文字へ置換処理をしますので記録はできません。", vbYesNo + vbQuestion, "確認")
    If rc = vbYes Then
    Else
        MsgBox "処理はキャンセルされました。"
        Exit Sub
    End If
    ActiveDocument.AcceptAllRevisions
'----------------------------------------------------------------------------------------------------
'空白全角変換(処理対象文書の先頭位置をrngに格納)
Set rng = ActiveDocument.Range(0, 0)
With rng.Find

'検索条件として半角空白を指定
.Text = " "
.MatchWildcards = False
End With

With rng
'検索箇所が見つかる間は処理を繰り返す
Do While .Find.Execute = True

'半角空白が見つかった場合、全角空白に変換
.Text = "　"

'rngが示す範囲の先頭位置を現在の末尾に変更する(検索結果の末尾に変更)
.SetRange .End, .End
Loop
End With
'----------------------------------------------------------------------------------------------------

'検索文字列------------------------------------------------------------------------------------------
a = Array("(", ")", "%", "（代）", "（株）", "（有）", "（１）", "（２）", "（３）", "（４）", "（５）", "~", _
"（６）", "（７）", "（８）", "（９）", "（10）", "（11）", "（12）", "（13）", "（14）", "（15）", "・・・")

'置換文字列-----------------------------------------------------------------------------------------
b = Array("（", "）", "％", "��", "��", "��", ChrW(&H2474), ChrW(&H2475), ChrW(&H2476), ChrW(&H2477), ChrW(&H2478), "〜", _
ChrW(&H2479), ChrW(&H247A), ChrW(&H247B), ChrW(&H247C), ChrW(&H247D), ChrW(&H247E), ChrW(&H247F), ChrW(&H2480), ChrW(&H2481), ChrW(&H2482), "…")
'----------------------------------------------------------------------------------------------------
For i = LBound(a) To UBound(a)

Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = a(i)
.Replacement.Text = b(i)
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
.MatchFuzzy = True
End With
Selection.Find.Execute Replace:=wdReplaceAll

Next
End Sub

Sub NNNその他NNNスペース､改行一括削除140811()
'---------------------------------------------
'選択範囲の空白・タブ・改行等を削除
'
Selection.WholeStory
    With Selection
        .Text = Replace(.Text, "　", "")            '全角空白削除
        .Text = Replace(.Text, " ", "")             '半角空白削除
        .Text = Replace(.Text, vbTab, "")           'タブ削除
        .Text = Replace(.Text, vbCr, "")            '改段落削除
        .Text = Replace(.Text, vbVerticalTab, "")   '改行削除
    End With
End Sub

Sub NNNその他NNN適当置換改行140821()
'
' 記録日 2014/08/12
'
  Selection.Find.ClearFormatting
  Selection.Find.Replacement.ClearFormatting
  With Selection.Find
    .Text = "。"
    .Replacement.Text = "。^p"
    .Forward = True
    .Wrap = wdFindContinue
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchByte = False
    .MatchAllWordForms = False
    .MatchSoundsLike = False
    .MatchWildcards = False
    .MatchFuzzy = False
    End With
  Selection.Find.Execute Replace:=wdReplaceAll
  Selection.Find.ClearFormatting
  Selection.Find.Replacement.ClearFormatting
  With Selection.Find
    .Text = "。^p」"
    .Replacement.Text = "。」^p"
    .Forward = True
    .Wrap = wdFindContinue
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchByte = False
    .MatchAllWordForms = False
    .MatchSoundsLike = False
    .MatchWildcards = False
    .MatchFuzzy = False
  End With
  Selection.Find.Execute Replace:=wdReplaceAll
  Selection.Find.ClearFormatting

End Sub

Sub NNNその他NNN曜日1文字変換()
Dim a As Variant '固定処理の為の置換用関数
Dim b As Variant '固定処理の為の置換用関数
Dim i As Integer '固定処理の為の置換用関数
Dim rc As Integer 'メッセージボックスのYesNoの為の関数
Dim rng As Range
Selection.WholeStory
'----------------------------------------------------------------------------------------------------
    rc = MsgBox("半角カッコを全角カッコに変換し、置換します。他の箇所に半角カッコがある場合も置換します。よろしいですか？", vbYesNo + vbQuestion, "確認")
    If rc = vbYes Then
    Else
        MsgBox "処理はキャンセルされました。"
        Exit Sub
    End If
'----------------------------------------------------------------------------------------------------

'検索文字列------------------------------------------------------------------------------------------
a = Array("(", ")", "（月）", "（火）", "（水）", "（木）", "（金）", "（土）", "（日）")

'置換文字列-----------------------------------------------------------------------------------------
b = Array("（", "）", ChrW(&H322A), ChrW(&H322B), ChrW(&H322C), ChrW(&H322D), ChrW(&H322E), ChrW(&H322F), ChrW(&H3230))
'----------------------------------------------------------------------------------------------------
For i = LBound(a) To UBound(a)
Selection.WholeStory
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = a(i)
.Replacement.Text = b(i)
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
.MatchFuzzy = True
End With
Selection.Find.Execute Replace:=wdReplaceAll

Next
End Sub

Sub 括弧aからzの1文字変換()
'----------------------------------------------------------------------------------------------------
Dim a As Variant '固定処理の為の置換用関数
Dim b As Variant '固定処理の為の置換用関数
Dim i As Integer '固定処理の為の置換用関数
Dim rc As Integer 'メッセージボックスのYesNoの為の関数
Dim rng As Range
Selection.WholeStory
'----------------------------------------------------------------------------------------------------
    rc = MsgBox("半角カッコを全角カッコに変換し、置換します。他の箇所に半角カッコがある場合も置換します。よろしいですか？", vbYesNo + vbQuestion, "確認")
    If rc = vbYes Then
    Else
        MsgBox "処理はキャンセルされました。"
        Exit Sub
    End If
'----------------------------------------------------------------------------------------------------

'検索文字列------------------------------------------------------------------------------------------
a = Array("(", ")", "（a）", "（b）", "（c）", "（d）", "（e）", "（f）", "（g）", "（h）", "（i）", "（j）", _
"（k）", "（l）", "（m）", "（n）", "（o）", "（p）", "（q）", "（r）", "（s）", "（t）", "（u）", "（v）", "（w）", "（x）", "（y）", "（z）")

'置換文字列-----------------------------------------------------------------------------------------
b = Array("（", "）", ChrW(&H249C), ChrW(&H249D), ChrW(&H249E), ChrW(&H249F), ChrW(&H24A0), ChrW(&H24A1), ChrW(&H24A2), ChrW(&H24A3), ChrW(&H24A4), ChrW(&H24A5), _
ChrW(&H24A6), ChrW(&H24A7), ChrW(&H24A8), ChrW(&H24A9), ChrW(&H24AA), ChrW(&H24AB), ChrW(&H24AC), ChrW(&H24AD), ChrW(&H24AE), ChrW(&H24AF), ChrW(&H24B0), ChrW(&H24B1), ChrW(&H24B2), ChrW(&H24B3), ChrW(&H24B4), ChrW(&H24B5))
'----------------------------------------------------------------------------------------------------
For i = LBound(a) To UBound(a)
Selection.WholeStory
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = a(i)
.Replacement.Text = b(i)
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = True 'ここがFalseの場合大文字Aも含む置換処理を行う
.MatchWholeWord = False
.MatchByte = True '半角と全角の区別
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
.MatchFuzzy = True
End With
Selection.Find.Execute Replace:=wdReplaceAll

Next
End Sub

Public Sub NNNその他NNN適当まとめてルビ振り()
'ルビ一括設定
  Dim r As Word.Range
  Dim pntc As String
  
  With CreateObject("Excel.Application")
    .Visible = True
    '単語単位で処理
    For Each r In ActiveDocument.Words
      If ChkKanjiRange(r) = True Then
        pntc = .GetPhonetic(r.Text)
        r.PhoneticGuide StrConv(pntc, vbHiragana)
      End If
    Next
    '文字単位で処理
    For Each r In ActiveDocument.Characters
      If ChkKanjiRange(r) = True Then
        pntc = .GetPhonetic(r.Text)
        r.PhoneticGuide StrConv(pntc, vbHiragana)
      End If
    Next
    .Quit
  End With
End Sub

Private Function ChkKanjiRange(ByVal rng As Word.Range) As Boolean
'指定したRangeが漢字のみかチェック
  Dim ret As Boolean
  Dim i As Long
  
  ret = True
  For i = 1 To Len(rng.Text)
    If IsKanji(Mid(rng.Text, i, 1)) = False Then
      ret = False
      Exit For
    End If
  Next
  ChkKanjiRange = ret
End Function

Private Function IsKanji(ByVal char As String) As Boolean
'漢字判別
'※ 参考Webページ
' - http://www.taishukan.co.jp/kokugo/webkoku/series003_04.html
' - http://en.wikipedia.org/wiki/CJK_Unified_Ideographs_%28Unicode_block%29
' - http://www.asahi-net.or.jp/~ax2s-kmtn/ref/unicode/e_asia.html
' - http://www.gsid.nagoya-u.ac.jp/ohna/notes/nu/regex4kanji2.txt
' - http://support.microsoft.com/kb/161304/ja
  Dim cc As Variant
  Dim ret As Boolean
  
  ret = True '初期化
  cc = Val("&H" & Hex(AscW(char)) & "&")
  'Debug.Print "CHK:" & cc
  Select Case cc
    Case 19968 To 40959   'CJK統合漢字(U+4E00-U+9FFF)
    Case 13312 To 19903   'CJK統合漢字拡張A(U+3400-U+4DBF)
    Case 131072 To 173791 'CJK統合漢字拡張B(U+20000-U+2A6DF)
    Case 173824 To 177983 'CJK統合漢字拡張C(U+2A700-U+2B73F)
    Case 177984 To 178207 'CJK統合漢字拡張D(U+2B740-U+2B81F)
    Case 63744 To 64255   'CJK互換漢字(U+F900-U+FAFF)
    Case 194560 To 195103 'CJK互換漢字補助(U+2F800-U+2FA1F)
    Case Else
      ret = False
  End Select
  IsKanji = ret
End Function

Sub 漢数字to算用数字変換()
'----------------------------------------
'MS-Word用マクロ：漢数字を英数字に変換
'○使うサブルーチン：
'    function conv2num(skan,[numform],[setcom])
'    function subconv2num(skan)  ' conv2num()のサブルーチン
'----------------------------------------
  Const NOCOM = 0   'コンマ不使用(規定値)
  Const COMMA = 1   'コンマ使用
  Const MIXNUM = 0  '万億兆を混在（3万6000）
  Const PURENUM = 1 '万億兆は不使用。（36,000)

  Dim flgMans As Long ' 0…4桁区切りを入れる(32万6,500円)／1…入れない(326,500円)
  Dim flgCom As Long  ' 0…カンマを使わない(2700万円)／1…使うわない(2,700万円)
  Dim str As String, kcketa As String, buf As String
  Dim ileng As Long
  Dim unit As String, headunit As String, piriunit As String, mansunit As String
  Dim sKancom As String ' 「、」をカンマとみなすかどうか設定
  Dim myRange As Range, para As Paragraph
  Dim RE As Object, RE2 As Object, Matches As Object, Match As Object
  Set RE = CreateObject("VBScript.RegExp")
  Set RE2 = CreateObject("VBScript.RegExp")
  RE.Global = False   'True:全ての検索結果を処理、False:初出の結果のみ処理
  RE2.Global = False
  
' -----------------  変換設定フラグ（不要な方をコメントアウト）----------
   'flgMansの設定：(漢数くん使用時は引数使用)
  flgMans = MIXNUM    '0(MIXNUM)…万億兆を混在（3万6000）
'  flgMans = PURENUM  ' 1(PURENUM)…万億兆は不使用(36,000)
   
   'flgComの設定：(漢数くん使用時は引数使用)
  flgCom = NOCOM  '0(NOCOM)…カンマを使わない(2700万円)
'  flgCom = COMMA   '1(COMMA)…使う(2,700万円)
  
   'sKancom設定：
  sKancom = ""  '[ = "" ]で、句読点をカンマとみなさない。
'  sKancom = "、"  '[ ="、" ]で、句読点をカンマとみなす。
     
' ------------------------------------------------------------------------

   ' 変換単位（複数文字可）
  unit = "(・|\.|人|名|円|年|月|日|時|分|秒|世紀|章|節|条|項|号|目|款|歳|番|番地" & _
    "|点|匹|頭|羽|冊|本|枚|台|機|回|軒|件|県|審|間|世帯|米|平方|立方" & _
    "|以上|以下|未満|を超え" & _
    "|キロ|メガ|トン|メートル|センチ|ミリ|マイクロ|ミクロン|ヤード|ポンド|インチ|エーカー" & _
    "|リットル|ガロン|ヘクト|パーセント|ベクレル|シーベルト|グレイ|ドル|ユーロ|元|ウォン" & _
    "|\%|％|cm|ｃｍ|Cm|Ｃｍ|℃|μ|m|ｍ|M|Ｍ|k|ｋ|K|Ｋ|Sv|Ｓｖ|Bq|Ｂｑ|Gy|Ｇｙ" & _
    "|光年|パーセク|ー)"
   ' 頭部変換単位（複数文字可）
  headunit = "(問|問題|人口|第|マッハ|ワープ|セシウム|カリウム|ヨウ素|炭素|ウラン|ストロンチウム)"
  mansunit = "(京|兆|億|万)"
   ' ピリオド単位
  piriunit = "(・|\.)"
  
   ' 変換範囲（段落=paragraph単位で変換）
  If Selection.Start = Selection.End Then
    Set myRange = ActiveDocument.Range   '範囲選択しなければ文書全体
  Else
    Set myRange = Selection.Range    '選択された範囲内の段落のみ
  End If
  
  For Each para In myRange.Paragraphs
      ' 文書を一気に変換すると表が解除されるのでパラグラフごとに変換
      ' 途中でパラグラフを移動させないため、文字列bufにコピーして作業
    buf = para.Range.Text
    
      '「**条『の**』」、「百分『の五十』」の部変換
    RE.Pattern = "([〇○一二三四五六七八九十百千]+)" & _
       "([章|節|条|項|分]の)([〇○一二三四五六七八九十百千]+)"
    Do
      Set Matches = RE.Execute(buf)
      If Matches.Count > 0 Then
        str = conv2num(Matches(0).SubMatches(0), flgMans, flgCom)
        str = str & Matches(0).SubMatches(1)
        str = str & conv2num(Matches(0).SubMatches(2), flgMans, flgCom)
        RE2.Pattern = Matches(0).Value
        buf = RE2.Replace(buf, str)
      End If
    Loop Until Matches.Count = 0
      '条・項・号変換
    RE.Pattern = "第([一二三四五六七八九十百千]+)(章|節|条|項|号)"
    Do
      Set Matches = RE.Execute(buf)
      If Matches.Count > 0 Then
        str = conv2num(Matches(0).SubMatches(0), flgMans, flgCom)
        str = "第" & str & Matches(0).SubMatches(1)
        RE2.Pattern = Matches(0).Value
        buf = RE2.Replace(buf, str)
      End If
    Loop Until Matches.Count = 0
          '小数点「・」以下変換　(十百千の桁文字持たないことが前提)
    RE.Pattern = piriunit & "([〇○一二三四五六七八九]+)"
    Do
      Set Matches = RE.Execute(buf)
      If Matches.Count > 0 Then
        str = conv2num(Matches(0).SubMatches(1), flgMans, NOCOM)
        str = "." & str
        RE2.Pattern = Matches(0).Value
        buf = RE2.Replace(buf, str)
      End If
    Loop Until Matches.Count = 0
      '「**人、**円、**年**月**日」部変換
      '2011/01/10：「二十万円」等で無限ループになるバグ修正
      '           （RE.Pattern、SubMatches(N)を変更）
    RE.Pattern = "(([〇○一二三四五六七八九十百千" & sKancom & "]+[万億兆京]*)+)" & unit
    Do
      Set Matches = RE.Execute(buf)
      If Matches.Count > 0 Then
            str = conv2num(Matches(0).SubMatches(0), flgMans, flgCom)
            str = str & Matches(0).SubMatches(2)  '単位結合
            RE2.Pattern = Matches(0).Value
            buf = RE2.Replace(buf, str)
      End If
    Loop Until Matches.Count = 0
      '「問**、マッハ**、ワープ**」など、頭部単位変換
    RE.Pattern = headunit & "([〇○一二三四五六七八九十百千]+)"
    Do
      Set Matches = RE.Execute(buf)
      If Matches.Count > 0 Then
        str = conv2num(Matches(0).SubMatches(1), flgMans, flgCom)
        str = Matches(0).SubMatches(0) & str  '単位結合
        RE2.Pattern = Matches(0).Value
        buf = RE2.Replace(buf, str)
      End If
    Loop Until Matches.Count = 0
    
' 行頭の「○３」を「�B」に変換。この機能を使いたい場合は、
' 次の行から、End Ifまでのコメント「'」を外してください。

'    RE.Pattern = "^○[０１２３４５６７８９]+"
'    Do
'      Set Matches = RE.Execute(buf)
'      If Matches.Count > 0 Then
'        ileng = Matches(0).Length
'        str = marumoji(Matches(0).Value, ileng)
'        RE2.Pattern = Matches(0).Value
'        buf = RE2.Replace(buf, str)
'      End If
'    Loop Until Matches.Count = 0

      ' 作業bufが変更されていたら、paragraph置き換え
    If buf <> para.Range.Text Then
      para.Range.Text = buf
    End If
  Next
  Set RE = Nothing
  Set Matches = Nothing
  Set Match = Nothing
  Set myRange = Nothing
End Sub
  
Function conv2num(skan As String, _
    Optional numform As Long, _
    Optional setcom As Long) As String
'------------------------------------------------------------------
' ○conv2num関数 ：漢数字の文字列を英数字の文字列に変換する。
' ○引数
'   skan  ：処理する漢数字（「五十万千七百五」,「五○一七〇五」どちらも可）
'   numform ：0(MIXNUM)…(規定値)万億兆京の表示／1(PURENUM)…算用数字のみ
'   setcom  ：0(NOCOM)…(規定値)カンマ不使用／1(COMMA)…3桁ごとにカンマ入れる
' ○戻り値
'   変換結果の文字列
' ○使うサブルーチン
'    function subconv2num(skan)
'------------------------------------------------------------------
  Const NOCOM = 0   'コンマ不使用(規定値)
  Const COMMA = 1   'コンマ使用
  Const MIXNUM = 0  '万億兆を混在（3万6000）
  Const PURENUM = 1 '万億兆は不使用。（36,000)
  Dim i As Long, ileng As Long, ipos As Long
  Dim swork As String, sbuf As String, buf As String, sdot As String
  Dim skei As String, styo As String, soku As String, sman As String, ssen As String
  Dim kkei As String, ktyo As String, koku As String, kman As String
  Dim RE As Object, Matches As Object
  Set RE = CreateObject("VBScript.RegExp")
  RE.Global = True   'True:全ての検索結果を処理、False:初出の結果のみ処理

  swork = skan
  ' 万億兆京が無い漢数字の場合（万未満、または「三○五八七」など）
  RE.Pattern = "[万億兆京]"
  Set Matches = RE.Execute(swork)
  If Matches.Count = 0 Then
    sbuf = subconv2num(swork)
    If setcom = COMMA Then
      sbuf = Format(sbuf, "#,###")
    End If
    conv2num = sbuf
    Exit Function
  End If
  
  ' 万以上の漢数字が存在する場合
  ipos = InStr(swork, "京")    '京の有無(無いとき0)
  If ipos > 0 Then
    buf = Left(swork, ipos - 1)   '京の数字
    skei = subconv2num(buf)
    swork = Right(swork, Len(swork) - ipos)   '京未満部分
    kkei = "京"
  Else
    skei = "": kkei = ""  'この桁が存在しないときは空白を接続
  End If
  ipos = InStr(swork, "兆")    '兆の有無(無いとき0)
  If ipos > 0 Then
    buf = Left(swork, ipos - 1)   '兆の数字
    styo = subconv2num(buf)
    styo = Format(styo, "0000")
    swork = Right(swork, Len(swork) - ipos)  '兆未満部分
    ktyo = "兆"
  Else
    styo = "0000": ktyo = ""
  End If
  ipos = InStr(swork, "億")    '億の有無(無いとき0)
  If ipos > 0 Then
    buf = Left(swork, ipos - 1)   '億の数字
    soku = subconv2num(buf)
    soku = Format(soku, "0000")
    swork = Right(swork, Len(swork) - ipos)   '億未満部分
    koku = "億"
  Else
    soku = "0000": koku = ""
  End If
  ipos = InStr(swork, "万")    '万の有無(無いとき0)
  If ipos > 0 Then
    buf = Left(swork, ipos - 1)   '万の数字
    sman = subconv2num(buf)
    sman = Format(sman, "0000")
    swork = Right(swork, Len(swork) - ipos)   '万未満部分
    kman = "万"
  Else
    sman = "0000": kman = ""
  End If
  If swork = "" Then
    ssen = "0000"    '万以下の部分がないとき0で埋め
  Else
    ssen = subconv2num(swork)   '万未満の数字
    ssen = Format(ssen, "0000")
  End If
  
        ' ※　関数Format( x , "#,###" )は、x = 0 のとき、空白を返す。
  If numform = PURENUM Then   ' 万億兆使わない指定のとき(例：6,543,210)
    sbuf = skei & styo & soku & sman & ssen
    sbuf = Format(sbuf, "#,###")
  Else
    If setcom = COMMA Then
      sbuf = Format(skei, "#,###") & kkei & Format(styo, "#,###") & ktyo & _
      Format(soku, "#,###") & koku & Format(sman, "#,###") & kman & Format(ssen, "#,###")
    Else
      sbuf = Format(skei, "####") & kkei & Format(styo, "####") & ktyo & _
      Format(soku, "####") & koku & Format(sman, "####") & kman & Format(ssen, "####")
    End If
  End If
  conv2num = sbuf
  Exit Function
End Function

Function subconv2num(skan As String) As String
'------------------------------------------------------------------
' ○subconv2num関数 ：漢字4桁（千百十一位）を算用数字に変換して返すサブ関数
' ○引数
'   skan  ：処理する漢数字（「二千七百五」,「二、七〇五」どちらも可）
' ○戻り値
'   変換結果の文字列（ex:二千七百五　→　2705）
'------------------------------------------------------------------
  Const KANopNUM = "〇○一二三四五六七八九、・"  '桁漢字無(ピリオド付）
  Const KANNUM = "一二三四五六七八九"     '桁漢字付き用
  Const KANKETA = "十百千"         '桁漢字（千まで）
  Const ALpNUM = "00123456789,."       '英数字（ピリオド付）
  Dim i As Long, ileng As Long, cnt As Long, iketa As Long, skpflg As Long
  Dim pos As Long, san As Long
  Dim kcsu As String, sbuf As String
  
  iketa = 1     '現在処理中の英数字の桁数
  sbuf = ""
  '桁漢字 [十百千] の有無で処理を分岐
  cnt = 0
  ileng = Len(skan)
  pos = ileng    'pos:漢字文字列中の処理中文字ポインタ
  For i = 1 To ileng
    cnt = cnt + InStr(KANKETA, Mid(skan, i, 1))
  Next
  If cnt = 0 Then
    '桁漢字を使わない表記の場合（例：二、七〇五）
    For i = 1 To ileng
      kcsu = Mid(skan, i, 1)
      sbuf = sbuf & Mid(ALpNUM, InStr(KANopNUM, kcsu), 1)
    Next
    sbuf = Replace(sbuf, ",", "") 'カンマ削除
  Else
    '桁漢字を使う表記の場合（例：二千七百五）
    Do
      skpflg = 0
      kcsu = Mid(skan, pos, 1)
      san = InStr(KANNUM, kcsu)
      If iketa > 1 Then
        If kcsu = Mid(KANKETA, iketa - 1, 1) Then
          pos = pos - 1
          If pos < 1 Then
            sbuf = "1" & sbuf
            Exit Do
          End If
          kcsu = Mid(skan, pos, 1)
          san = InStr(KANNUM, kcsu)
        Else
          sbuf = "0" & sbuf
          iketa = iketa + 1
          skpflg = 1
        End If
      End If
      If skpflg = 0 Then
        If san = 0 Then
          If iketa = 1 Then
            sbuf = "0"
          Else
            sbuf = "1" & sbuf
          End If
          iketa = iketa + 1
        Else
          sbuf = san & sbuf
          iketa = iketa + 1
          pos = pos - 1
        End If
      End If
    Loop While iketa <= 4 And pos > 0
  End If
  subconv2num = sbuf
  Exit Function
End Function

Function marumoji(skan As String, ileng) As String
'---------------------------------------------------------------------
' ○marumoji関数 ：「○３」形式の標記を「�B」に変換する。
' ○引数
'     skan  ：処理する漢数字（例：「○３」,「○１２」）
'     ileng ：処理する文字列の長さ（「○１２」なら3)
' ○戻り値
'     変換結果の文字列（○２０以上は[21]のように変換）
'---------------------------------------------------------------------

    Dim skcsan As String, sansu As String, smarusu As String
    Dim kcsu As String, sbuf As String
    Dim i, cnt
    skcsan = "０１２３４５６７８９"         '桁漢字有り用
    sansu = "0123456789"                    '桁漢字無し用置き換え英数字
    smarusu = "�@�A�B�C�D�E�F�G�H�I�J�K�L�M�N�O�P�Q�R�S"    '丸付数字
    sbuf = ""
    For i = 2 To ileng
        kcsu = Mid(skan, i, 1)
        sbuf = sbuf & Mid(sansu, InStr(skcsan, kcsu), 1)
    Next
    cnt = Val(sbuf)
    If cnt > 20 Or cnt = 0 Then
        marumoji = "[" & sbuf & "]"
    Else
        marumoji = Mid(smarusu, cnt, 1)
    End If
    Exit Function
End Function
                                              
Sub 適当縦中横文字変換()
Dim moji As Range

'文章中の単語をすべてチェックする
For Each moji In ActiveDocument.Words
 
'半角数字なら
    If IsNumeric(moji) Then
    
'幅を行幅に合わせて縦中横文字に置換する
        moji.HorizontalInVertical = wdHorizontalInVerticalFitInLine
    End If
Next

End Sub

Sub BBB縦書きBBB数字三桁から十桁までを全角置換v151112()
           
Dim rc As Integer
Dim rng As Range

Application.Run MacroName:="AAA横書きAAA数字と簡易文字全角変換v151130"

Set rng = ActiveDocument.Range(0, 0)
Selection.WholeStory
  
  With rng.Find
'4桁以上の半角数字だけを対象にしています。
    .Text = "[0-9]{3,10}"
'{4,}（←4桁以上）を{4,4}にすれば4桁のみの半角数字を対象にしますし、{1,4}にすれば4桁までを対象にします。
    .MatchWildcards = True
  End With

  With rng
    Do While .Find.Execute = True
    .CharacterWidth = wdWidthFullWidth
    .SetRange .End, .End
  Loop
End With
    rc = MsgBox("縦中横処理を行いますか？（その際横書きのテキスト等混ざっているとズレが発生します", vbYesNo + vbQuestion, "確認")
    If rc = vbYes Then
    Else
        MsgBox "処理はキャンセルされました。"
        Exit Sub
    End If
           Application.Run MacroName:="適当縦中横文字変換"
        MsgBox "処理終了。"
End Sub

Sub NNNその他NNN半角カタカナ英字を全角置換V151112()
    Selection.Find.Execute
    Selection.WholeStory
    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = "[ｦ-ﾟ]"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchByte = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchFuzzy = False
        .MatchWildcards = True
    End With
    Selection.Range.CharacterWidth = wdWidthFullWidth
End Sub
Sub 英字半角()
    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = "[a-zA-Zａ-ｚＡ-Ｚ]"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindAsk
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchByte = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchFuzzy = False
        .MatchWildcards = True
    End With
    Selection.Range.CharacterWidth = wdWidthHalfWidth
End Sub

Public Sub Sample_StyleToTag()
'ループでまとめて処理(タグ化)
  Dim s(1 To 9) As String
  Dim i As Long
 
  s(1) = "i"
  s(2) = "b"
  s(3) = "u"
  s(4) = "s"
  s(5) = "ds"
  s(6) = "sup"
  s(7) = "sub"
  s(8) = "h1"
  s(9) = "p"
 
  For i = LBound(s) To UBound(s)
    StyleToTag s(i)
  Next
End Sub

Public Sub Sample_TagToStyle()
'ループでまとめて処理(装飾化)
  Dim s(1 To 9) As String
  Dim i As Long
 

  s(1) = "i"
  s(2) = "b"
  s(3) = "u"
  s(4) = "s"
  s(5) = "ds"
  s(6) = "sup"
  s(7) = "sub"
  s(8) = "h1"
  s(9) = "p"
 
  For i = LBound(s) To UBound(s)
    TagToStyle s(i)
  Next
End Sub

Private Sub StyleToTag(ByVal sTag As String)
'装飾をタグ化
  Dim r As Word.Range
  Dim myRange As Word.Range
 
  Set myRange = Selection.Range
  Set r = ActiveDocument.Range(0, 0)
  With r.Find
    .ClearFormatting
    .Format = True
    .Forward = True
    .MatchWildcards = False
    .Text = vbNullString
  
    '装飾検索(条件設定)
    Select Case LCase$(sTag)
      Case "b": .Font.Bold = True '太字
      Case "i": .Font.Italic = True '斜体
      Case "u": .Font.Underline = wdUnderlineSingle '下線
      Case "s": .Font.StrikeThrough = True '取り消し線
      Case "ds": .Font.DoubleStrikeThrough = True '二重取り消し線
      Case "sup": .Font.Superscript = True '上付き文字
      Case "sub": .Font.Subscript = True '下付き文字
      Case "h1": .Style = ActiveDocument.Styles("見出し 1") '[見出し 1]
      Case "p": .Style = ActiveDocument.Styles("本文") '[本文]
      Case Else
        MsgBox "対応していない形式です。" & vbCrLf & "処理を中止します。", vbCritical + vbSystemModal
        Exit Sub
    End Select
  
    Do While .Execute
      If InStr(r.Text, vbCr) Then
        If vbCr <> r.Text Then
            r.End = r.End - 1
            r.InsertBefore "<" & sTag & ">"
            r.InsertAfter "</" & sTag & ">"
        Else
            'r自体が改行記号の場合→何もしない
        End If
      Else
        r.InsertBefore "<" & sTag & ">"
        r.InsertAfter "</" & sTag & ">"
      End If
   
      '装飾解除
      Select Case LCase$(sTag)
        Case "b": r.Font.Bold = False
        Case "i": r.Font.Italic = False
        Case "u": r.Font.Underline = wdUnderlineNone
        Case "s": r.Font.StrikeThrough = False
        Case "ds": r.Font.DoubleStrikeThrough = False
        Case "sup": r.Font.Superscript = False
        Case "sub": r.Font.Subscript = False
        Case "h1", "p": r.Select: Selection.ClearFormatting
      End Select
   
      r.Collapse wdCollapseEnd
    Loop
    .ClearFormatting
  End With
 
  myRange.Select
  Set r = Nothing
  Set myRange = Nothing
 
End Sub

Private Sub TagToStyle(ByVal sTag As String)
'タグを装飾化
  Dim r As Word.Range
  Dim myRange As Word.Range
 
  Set myRange = Selection.Range
  '対応チェック
  Select Case LCase$(sTag)
    Case "b", "i", "u", "s", "ds", "sup", "sub", "h1", "p":
    Case Else
      MsgBox "対応していない形式です。" & vbCrLf & "処理を中止します。", vbCritical + vbSystemModal
      Exit Sub
  End Select
 
  Set r = ActiveDocument.Range(0, 0)
  With r.Find
    .ClearFormatting
    .Format = False
    .Forward = True
    .MatchFuzzy = False
    .MatchWildcards = True
    .Text = "\<" & sTag & "\>*\</" & sTag & "\>"
    Do While .Execute
      '装飾実施
      Select Case LCase$(sTag)
        Case "b": r.Font.Bold = True
        Case "i": r.Font.Italic = True
        Case "u": r.Font.Underline = wdUnderlineSingle
        Case "s": r.Font.StrikeThrough = True
        Case "ds": r.Font.DoubleStrikeThrough = True
        Case "sup": r.Font.Superscript = True
        Case "sub": r.Font.Subscript = True
        Case "h1": r.Style = ActiveDocument.Styles("見出し 1")
        Case "p": r.Style = ActiveDocument.Styles("本文")
      End Select
   
      'タグ除去
      Selection.SetRange r.End - Len(sTag) - 3, r.End
      Selection.Delete
      Selection.SetRange r.Start, r.Start + Len(sTag) + 2
      Selection.Delete
   
      r.Collapse wdCollapseEnd
    Loop
    .ClearFormatting
  End With
 
  myRange.Select
  Set r = Nothing
 Set myRange = Nothing

End Sub

Sub CCC全角カタカナへ置換CCC()
Dim F As Find
Dim Ans

Set F = Selection.Find
Call Target(F)

' 句読点や括弧も含める場合、&HA6を&HA1に変更
F.Text = "[" & Chr(&HA6) & "-" & Chr(&HDF) & "]{1,}"
Selection.HomeKey unit:=wdStory

Do While F.Execute = True
With Selection
Ans = MsgBox(.Text & "を全角にしますか？", vbYesNoCancel)
If Ans = vbYes Then
.Words(1).Case = wdFullWidth
.Collapse Direction:=wdCollapseEnd
ElseIf Ans = vbCancel Then
End
End If
End With
Loop
End Sub

Sub DDD半角カタカナへ置換DDD()
Dim F As Find
Dim Ans

Set F = Selection.Find
Call Target(F)

F.Text = "[ァ-" & ChrW(Val("&h30FA")) & "]{1,}"

Selection.HomeKey unit:=wdStory

Do While F.Execute = True
With Selection
Ans = MsgBox(.Text & "を半角にしますか？", vbYesNoCancel)
If Ans = vbYes Then
.Words(1).Case = wdHalfWidth
.Collapse Direction:=wdCollapseEnd
ElseIf Ans = vbCancel Then
End
End If
End With
Loop
End Sub

Sub Target(F)
With F
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.MatchByte = False
.MatchFuzzy = False
.MatchWildcards = True
End With
End Sub

Sub Unicode強調()

'//JIS X0208外の文字をチェックして、背景色を設定する。
'//ただしJIS X0208にある文字だが、U+301C 波ダッシュも、背景色が付いてしまう。

Dim r As Range
Dim strMoji As String
Dim lngMojiCd As Long

Application.ScreenUpdating = False

For Each r In ActiveDocument.Characters
strMoji = r.Text
'//Unicodeチェック
If StrConv(StrConv(strMoji, vbFromUnicode), vbUnicode) <> strMoji Then
r.HighlightColorIndex = wdYellow
Else
'//NEC特殊文字、IBM拡張文字チェック
lngMojiCd = Asc(strMoji)
If lngMojiCd > 0 Then
'//Nop 半角文字
ElseIf lngMojiCd > -5468 Then '//熙
r.HighlightColorIndex = wdBrightGreen
Else
If lngMojiCd >= -30912 And lngMojiCd <= -30820 Then '//�@ ∪(NEC特殊文字の「∪」)
r.HighlightColorIndex = wdBrightGreen
ElseIf lngMojiCd = -32416 Then '//全角チルダ
r.HighlightColorIndex = wdPink
End If
End If
End If
Next r

Application.ScreenUpdating = True

End Sub